Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH3/SRC/PALWATCH.FRM

Text File | 1997-01-02 | 8KB | 299 lines

VERSION 4.00
Begin VB.Form PalWatchForm
   Caption         =   "PalWatch"
   ClientHeight    =   2460
   ClientLeft      =   6810
   ClientTop       =   975
   ClientWidth     =   2460
   Height          =   3150
   Left            =   6750
   LinkTopic       =   "Form1"
   ScaleHeight     =   164
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   164
   Top             =   345
   Width           =   2580
   Begin VB.Timer ColorTimer
      Interval        =   1000
      Left            =   120
      Top             =   120
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   300
      Left            =   0
      Picture         =   "PALWATCH.frx":0000
      ScaleHeight     =   16
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   16
      TabIndex        =   0
      Top             =   0
      Width           =   300
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuColor
      Caption         =   "(0, 0, 0)"
      NegotiatePosition=   3  'Right
   End
End
Attribute VB_Name = "PalWatchForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Const NO_COLOR = -1

Dim LogicalPalette As Integer

Dim SysPalSize As Integer
Dim NumStaticColors As Integer

Dim SelectedI As Integer
Dim SelectedJ As Integer
Dim SelectedColor As Integer
Dim SelectedR As Integer
Dim SelectedG As Integer
Dim SelectedB As Integer

Dim dx As Integer
Dim dy As Integer

' ***********************************************
' Load the Pict palette with PC_EXPLICIT entries
' so they match the system palette.
' ***********************************************
Sub LoadSystemPalette()
Dim palentry(0 To 255) As PALETTEENTRY
Dim i As Integer

    ' Make the logical palette as big as possible.
    LogicalPalette = Pict.Picture.hPal
    If ResizePalette(LogicalPalette, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing the palette.", _
            vbCritical
        End
    End If

    ' Flag all palette entries as PC_EXPLICIT.
    ' Set peRed to the system palette indexes.
    For i = 0 To SysPalSize - 1
        palentry(i).peRed = i
        palentry(i).peFlags = PC_EXPLICIT
    Next i

    ' Update the palette (ignore return value).
    i = SetPaletteEntries(LogicalPalette, 0, SysPalSize, palentry(0))
End Sub

' ***********************************************
' Fill the system picture with all the palette
' colors, hatching the static colors.
' ***********************************************
Sub FillPict()
Dim i As Integer
Dim j As Integer
Dim clr As Integer
Dim oldfill As Integer
Dim olddraw As Integer

    Pict.Cls

    ' Display the colors using palette indexing.
    dx = Pict.ScaleWidth / 16
    dy = Pict.ScaleHeight / 16
    clr = 0
    For i = 0 To 15
        For j = 0 To 15
            Pict.Line (j * dx, i * dy)-Step(dx, dy), _
                clr + &H1000000, BF
            clr = clr + 1
        Next j
    Next i

    ' Hatch the static colors.
    oldfill = Pict.FillStyle
    olddraw = Pict.DrawMode
    Pict.FillStyle = vbDownwardDiagonal
    Pict.DrawMode = vbInvisible

    Pict.Line (0, 0)-Step((NumStaticColors \ 2) * dx - 1, dy - 1), , B
    Pict.Line (j * dx, i * dy)-Step(-(NumStaticColors \ 2) * dx, -dy), , B

    Pict.FillStyle = oldfill
    Pict.DrawMode = olddraw

    ' Highlight the previously selected color.
    SelectedColor = NO_COLOR
    SelectColor SelectedI, SelectedJ
End Sub

' ***********************************************
' Select the color at the indicated position.
' ***********************************************
Sub SelectColor(ByVal i As Integer, ByVal j As Integer)
Const GAP1 = 1
Const GAP2 = 2
Const DRAW_WID = 2

Dim oldmode As Integer
Dim oldwid As Integer

    oldmode = Pict.DrawMode
    oldwid = Pict.DrawWidth
    Pict.DrawMode = vbInvert
    Pict.DrawWidth = DRAW_WID

    ' Unhighlight the previously selected color.
    If SelectedColor <> NO_COLOR Then _
        Pict.Line (SelectedJ * dx + GAP1, SelectedI * dx + GAP1)-Step(dx - GAP2, dx - GAP2), , B

    ' Record the new color.
    SelectedI = i
    SelectedJ = j
    SelectedColor = i * 16 + j

    ' Highlight the new color.
    Pict.Line (SelectedJ * dx + GAP1, SelectedI * dx + GAP1)-Step(dx - GAP2, dx - GAP2), , B
    Pict.DrawMode = oldmode
    Pict.DrawWidth = oldwid

    ' Display the color's components in mnuColor.
    ShowColorValue
End Sub


' ***********************************************
' If the selected color's components have
' changed, display the new values in mnuColor.
' ***********************************************
Sub ShowColorValue()
Dim palentry As PALETTEENTRY
Dim status As Integer

    status = GetSystemPaletteEntries(Pict.hdc, SelectedColor, 1, palentry)
    If palentry.peRed <> SelectedR Or _
       palentry.peGreen <> SelectedG Or _
       palentry.peBlue <> SelectedB Then
            mnucolor.Caption = "(" & _
                Format$(palentry.peRed) & "," & _
                Str$(palentry.peGreen) & "," & _
                Str$(palentry.peBlue) & ")"
    End If
End Sub

' ***********************************************
' Make sure the selected color's components are
' up to date.
' ***********************************************
Private Sub ColorTimer_Timer()
    ShowColorValue
End Sub
Private Sub Form_Load()
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If

    ' See how big the system palette is.
    SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)

    NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)

    ' Load the system palette.
    LoadSystemPalette
End Sub

' ***********************************************
' Make the picture as large as possible.
' ***********************************************
Private Sub Form_Resize()
Dim wid As Single
Dim hgt As Single

    If WindowState = vbMinimized Then Exit Sub

    wid = ScaleWidth - 2 * Pict.Left
    If wid < 10 Then wid = 10
    hgt = ScaleHeight - 2 * Pict.Top
    If hgt < 10 Then hgt = 10
    Pict.Move Pict.Left, Pict.Top, wid, hgt

    ' Display the colors.
    FillPict
End Sub



' ***********************************************
' Select the color the user clicked on.
' ***********************************************
Private Sub Pict_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
Dim j As Integer

    i = Y \ dx
    j = X \ dy
    SelectColor i, j
End Sub

Private Sub mnuFileExit_Click()
    Unload Me
End Sub


' ***********************************************
' Allow the user to select a new color with the
' arrow keys.
' ***********************************************
Private Sub Pict_KeyDown(KeyCode As Integer, Shift As Integer)
Dim i As Integer
Dim j As Integer

    i = SelectedI
    j = SelectedJ

    Select Case KeyCode
        Case vbKeyDown
            i = i + 1
            If i * 16 + j >= SysPalSize Then i = 0

        Case vbKeyUp
            i = i - 1
            If i < 0 Then
                i = (SysPalSize - 1) \ 16
                If i * 16 + j >= SysPalSize Then _
                    i = i - 1
            End If

        Case vbKeyLeft
            j = j - 1
            If j < 0 Then
                j = 15
                If i * 16 + j >= SysPalSize Then _
                    j = SysPalSize - 1 - i * 16
            End If

        Case vbKeyRight
            j = j + 1
            If j > 15 Or _
                i * 16 + j >= SysPalSize Then _
                    j = 0

    End Select

    SelectColor i, j
End Sub